Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Applications/P4⁄Mac 2.0d4/Mac source 2.0/pascalcompiler.p

Text File | 1996-09-28 | 20.9 KB | 1,011 lines | [TEXT/PJMM]

(*$c+,t-,d-,l-*)
 (***********************************************}
{  *                        *}
{  *     Portable Pascal compiler        *}
{  *     ************************        *}
{  *                        *}
{  *        Pascal P4            *}
{  *                        *}
{  *     Authors:                *}
{  *          Urs Ammann            *}
{  *          Kesav Nori            *}
{  *          Christian Jacobi            *}
{  *     Address:                *}
{  *      Institut Fuer Informatik        *}
{  *      Eidg. Technische Hochschule        *}
{  *      CH-8096 Zuerich            *}
{  *                        *}
{  *  This code is fully documented in the book    *}
{  *       "Pascal Implementation"        *}
{  *   by Steven Pemberton and Martin Daniels    *}
{  * published by Ellis Horwood, Chichester, UK    *}
{  *        ISBN: 0-13-653-0311            *}
{  *       (also available in Japanese)        *}
{  *                        *}
{  * Steven Pemberton, CWI/AA,            *}
{  * Kruislaan 413, 1098 SJ Amsterdam, NL    *}
{  * [e-mail]            *}
{  *                        *}
{  ***********************************************)

{P4/Mac port by Ingemar Ragenamlm 1994-1996}

unit pascalcompiler; {(input, output, prr)}

interface
    uses
        Messages, NewOldFile, pcom1, block, pcode;


    procedure InitCompiler;
    function RunCompiler (fileName: Str255): Str255;


implementation

    procedure programme (fsys: setofsys);
        var
            extfp: extfilep;
    begin
        if sy = progsy then
            begin
                insymbol;
                if sy <> ident then
                    error(2);
                insymbol;
                if not (sy in [lparent, semicolon]) then
                    error(14);
                if sy = lparent then
                    begin
                        repeat
                            insymbol;
                            if sy = ident then
                                begin
                                    new(extfp);
                                    with extfp^ do
                                        begin
                                            filename := id;
                                            nextfile := fextfilep
                                        end;
                                    fextfilep := extfp;
                                    insymbol;
                                    if not (sy in [comma, rparent]) then
                                        error(20)
                                end
                            else
                                error(2)
                        until sy <> comma;
                        if sy <> rparent then
                            error(4);
                        insymbol
                    end;
                if sy <> semicolon then
                    error(14)
                else
                    insymbol;
            end;
        repeat
            block(fsys, period, nil);
            if sy <> period then
                error(21)
        until (sy = period) or eof(input);
        if list then
            WriteLnMessage;
        if errinx <> 0 then
            begin
                list := false;
                endofline
            end
    end; (*programme*)


    procedure stdnames;
    begin
        na[1] := 'false   ';
        na[2] := 'true    ';
        na[3] := 'input   ';
        na[4] := 'output  ';
        na[5] := 'get     ';
        na[6] := 'put     ';
        na[7] := 'reset   ';
        na[8] := 'rewrite ';
        na[9] := 'read    ';
        na[10] := 'write   ';
        na[11] := 'pack    ';
        na[12] := 'unpack  ';
        na[13] := 'new     ';
        na[14] := 'release ';
        na[15] := 'readln  ';
        na[16] := 'writeln ';
        na[17] := 'abs     ';
        na[18] := 'sqr     ';
        na[19] := 'trunc   ';
        na[20] := 'odd     ';
        na[21] := 'ord     ';
        na[22] := 'chr     ';
        na[23] := 'pred    ';
        na[24] := 'succ    ';
        na[25] := 'eof     ';
        na[26] := 'eoln    ';
        na[27] := 'sin     ';
        na[28] := 'cos     ';
        na[29] := 'exp     ';
        na[30] := 'sqrt    ';
        na[31] := 'ln      ';
        na[32] := 'arctan  ';
        na[33] := 'prd     ';
        na[34] := 'prr     ';
        na[35] := 'mark    ';
    end; (*stdnames*)

    procedure enterstdtypes;

    begin                         (*type underlying:*)
                            (******************)

        new(intptr, scalar, standard);                  (*integer*)
        with intptr^ do
            begin
                size := intsize;
                form := scalar;
                scalkind := standard
            end;
        new(realptr, scalar, standard);                 (*real*)
        with realptr^ do
            begin
                size := realsize;
                form := scalar;
                scalkind := standard
            end;
        new(charptr, scalar, standard);                 (*char*)
        with charptr^ do
            begin
                size := charsize;
                form := scalar;
                scalkind := standard
            end;
        new(boolptr, scalar, declared);                 (*boolean*)
        with boolptr^ do
            begin
                size := boolsize;
                form := scalar;
                scalkind := declared
            end;
        new(nilptr, pointer);                      (*nil*)
        with nilptr^ do
            begin
                eltype := nil;
                size := ptrsize;
                form := pointer
            end;
        new(parmptr, scalar, standard); (*for alignment of parameters*)
        with parmptr^ do
            begin
                size := parmsize;
                form := scalar;
                scalkind := standard
            end;
        new(textptr, files);                       (*text*)
        with textptr^ do
            begin
                filtype := charptr;
                size := charsize;
                form := files
            end
    end; (*enterstdtypes*)

    procedure entstdnames;
        var
            cp, cp1: ctp;
            i: integer;
    begin                               (*name:*)
                                  (*******)

        new(cp, types);                        (*integer*)
        with cp^ do
            begin
                name := 'integer ';
                idtype := intptr;
                klass := types
            end;
        enterid(cp);
        new(cp, types);                        (*real*)
        with cp^ do
            begin
                name := 'real    ';
                idtype := realptr;
                klass := types
            end;
        enterid(cp);
        new(cp, types);                        (*char*)
        with cp^ do
            begin
                name := 'char    ';
                idtype := charptr;
                klass := types
            end;
        enterid(cp);
        new(cp, types);                        (*boolean*)
        with cp^ do
            begin
                name := 'boolean ';
                idtype := boolptr;
                klass := types
            end;
        enterid(cp);
        cp1 := nil;
        for i := 1 to 2 do
            begin
                new(cp, konst);                    (*false,true*)
                with cp^ do
                    begin
                        name := na[i];
                        idtype := boolptr;
                        next := cp1;
                        values.ival := i - 1;
                        klass := konst
                    end;
                enterid(cp);
                cp1 := cp
            end;
        boolptr^.fconst := cp;
        new(cp, konst);                        (*nil*)
        with cp^ do
            begin
                name := 'nil     ';
                idtype := nilptr;
                next := nil;
                values.ival := 0;
                klass := konst
            end;
        enterid(cp);
        for i := 3 to 4 do
            begin
                new(cp, vars);                     (*input,output*)
                with cp^ do
                    begin
                        name := na[i];
                        idtype := textptr;
                        klass := vars;
                        vkind := actual;
                        next := nil;
                        vlev := 1;
                        vaddr := lcaftermarkstack + (i - 3) * charmax;
                    end;
                enterid(cp)
            end;
        for i := 33 to 34 do
            begin
                new(cp, vars);                     (*prd,prr files*)
                with cp^ do
                    begin
                        name := na[i];
                        idtype := textptr;
                        klass := vars;
                        vkind := actual;
                        next := nil;
                        vlev := 1;
                        vaddr := lcaftermarkstack + (i - 31) * charmax;
                    end;
                enterid(cp)
            end;
        for i := 5 to 16 do
            begin
                new(cp, proc, standard);                (*get,put,reset*)
                with cp^ do                       (*rewrite,read*)
                    begin
                        name := na[i];
                        idtype := nil;         (*write,pack*)
                        next := nil;
                        key := i - 4;            (*unpack,pack*)
                        klass := proc;
                        pfdeckind := standard
                    end;
                enterid(cp)
            end;
        new(cp, proc, standard);
        with cp^ do
            begin
                name := na[35];
                idtype := nil;
                next := nil;
                key := 13;
                klass := proc;
                pfdeckind := standard
            end;
        enterid(cp);
        for i := 17 to 26 do
            begin
                new(cp, func, standard);                (*abs,sqr,trunc*)
                with cp^ do                       (*odd,ord,chr*)
                    begin
                        name := na[i];
                        idtype := nil;         (*pred,succ,eof*)
                        next := nil;
                        key := i - 16;
                        klass := func;
                        pfdeckind := standard
                    end;
                enterid(cp)
            end;
        new(cp, vars);              (*parameter of predeclared functions*)
        with cp^ do
            begin
                name := '        ';
                idtype := realptr;
                klass := vars;
                vkind := actual;
                next := nil;
                vlev := 1;
                vaddr := 0
            end;
        for i := 27 to 32 do
            begin
                new(cp1, func, declared, actual);            (*sin,cos,exp*)
                with cp1^ do                      (*sqrt,ln,arctan*)
                    begin
                        name := na[i];
                        idtype := realptr;
                        next := cp;
                        forwdecl := false;
                        externl := true;
                        pflev := 0;
                        pfname := i - 12;
                        klass := func;
                        pfdeckind := declared;
                        pfkind := actual
                    end;
                enterid(cp1)
            end
    end; (*entstdnames*)

    procedure enterundecl;
        var
            temp: integer;
    begin
        new(utypptr, types);
        with utypptr^ do
            begin
                name := '        ';
                idtype := nil;
                klass := types
            end;
        new(ucstptr, konst);
        with ucstptr^ do
            begin
                name := '        ';
                idtype := nil;
                next := nil;
                values.ival := 0;
                klass := konst
            end;
        new(uvarptr, vars);
        with uvarptr^ do
            begin
                name := '        ';
                idtype := nil;
                vkind := actual;
                next := nil;
                vlev := 0;
                vaddr := 0;
                klass := vars
            end;
        new(ufldptr, field);
        with ufldptr^ do
            begin
                name := '        ';
                idtype := nil;
                next := nil;
                fldaddr := 0;
                klass := field
            end;
        new(uprcptr, proc, declared, actual);
        with uprcptr^ do
            begin
                name := '        ';
                idtype := nil;
                forwdecl := false;
                next := nil;
                externl := false;
                pflev := 0;

{Think Pascal won't pass a component of a packed record as var parameter!}
{genlabel(pfname);}
                temp := pfname; {FIX}
                genlabel(temp); {FIX}
                pfname := temp; {FIX}

                klass := proc;
                pfdeckind := declared;
                pfkind := actual
            end;
        new(ufctptr, func, declared, actual);
        with ufctptr^ do
            begin
                name := '        ';
                idtype := nil;
                next := nil;
                forwdecl := false;
                externl := false;
                pflev := 0;

{Think Pascal won't pass a component of a packed record as var parameter!}
{genlabel(pfname);}
                temp := pfname; {FIX}
                genlabel(temp); {FIX}
                pfname := temp; {FIX}

                klass := func;
                pfdeckind := declared;
                pfkind := actual
            end
    end; (*enterundecl*)

    procedure initscalars;
    begin
        fwptr := nil;
        prtables := false;
        list := true;
        prcode := true;
        debug := true;
        dp := true;
        prterr := true;
        errinx := 0;
        intlabel := 0;
        kk := 8;
        fextfilep := nil;
        lc := lcaftermarkstack + filebuffer * charmax;
    (* note in the above reservation of buffer store for 2 text files *)
        ic := 3;
        eol := true;
        linecount := 0;
        ch := ' ';
        chcnt := 0;
        globtestp := nil;
        mxint10 := maxint div 10;
        digmax := strglgth - 1;
    end; (*initscalars*)

    procedure initsets;
    begin
        constbegsys := [addop, intconst, realconst, stringconst, ident];
        simptypebegsys := [lparent] + constbegsys;
        typebegsys := [arrow, packedsy, arraysy, recordsy, setsy, filesy] + simptypebegsys;
        typedels := [arraysy, recordsy, setsy, filesy];
        blockbegsys := [labelsy, constsy, typesy, varsy, procsy, funcsy, beginsy];
        selectsys := [arrow, period, lbrack];
        facbegsys := [intconst, realconst, stringconst, ident, lparent, lbrack, notsy];
        statbegsys := [beginsy, gotosy, ifsy, whilesy, repeatsy, forsy, withsy, casesy];
    end; (*initsets*)

    procedure inittables;
        procedure reswords;
        begin
            rw[1] := 'if      ';
            rw[2] := 'do      ';
            rw[3] := 'of      ';
            rw[4] := 'to      ';
            rw[5] := 'in      ';
            rw[6] := 'or      ';
            rw[7] := 'end     ';
            rw[8] := 'for     ';
            rw[9] := 'var     ';
            rw[10] := 'div     ';
            rw[11] := 'mod     ';
            rw[12] := 'set     ';
            rw[13] := 'and     ';
            rw[14] := 'not     ';
            rw[15] := 'then    ';
            rw[16] := 'else    ';
            rw[17] := 'with    ';
            rw[18] := 'goto    ';
            rw[19] := 'case    ';
            rw[20] := 'type    ';
            rw[21] := 'file    ';
            rw[22] := 'begin   ';
            rw[23] := 'until   ';
            rw[24] := 'while   ';
            rw[25] := 'array   ';
            rw[26] := 'const   ';
            rw[27] := 'label   ';
            rw[28] := 'repeat  ';
            rw[29] := 'record  ';
            rw[30] := 'downto  ';
            rw[31] := 'packed  ';
            rw[32] := 'forward ';
            rw[33] := 'program ';
            rw[34] := 'function';
            rw[35] := 'procedur';
            frw[1] := 1;
            frw[2] := 1;
            frw[3] := 7;
            frw[4] := 15;
            frw[5] := 22;
            frw[6] := 28;
            frw[7] := 32;
            frw[8] := 34;
            frw[9] := 36;
        end; (*reswords*)

        procedure symbols;
        begin
            rsy[1] := ifsy;
            rsy[2] := dosy;
            rsy[3] := ofsy;
            rsy[4] := tosy;
            rsy[5] := relop;
            rsy[6] := addop;
            rsy[7] := endsy;
            rsy[8] := forsy;
            rsy[9] := varsy;
            rsy[10] := mulop;
            rsy[11] := mulop;
            rsy[12] := setsy;
            rsy[13] := mulop;
            rsy[14] := notsy;
            rsy[15] := thensy;
            rsy[16] := elsesy;
            rsy[17] := withsy;
            rsy[18] := gotosy;
            rsy[19] := casesy;
            rsy[20] := typesy;
            rsy[21] := filesy;
            rsy[22] := beginsy;
            rsy[23] := untilsy;
            rsy[24] := whilesy;
            rsy[25] := arraysy;
            rsy[26] := constsy;
            rsy[27] := labelsy;
            rsy[28] := repeatsy;
            rsy[29] := recordsy;
            rsy[30] := downtosy;
            rsy[31] := packedsy;
            rsy[32] := forwardsy;
            rsy[33] := progsy;
            rsy[34] := funcsy;
            rsy[35] := procsy;
            ssy['+'] := addop;
            ssy['-'] := addop;
            ssy['*'] := mulop;
            ssy['/'] := mulop;
            ssy['('] := lparent;
            ssy[')'] := rparent;
            ssy['$'] := othersy;
            ssy['='] := relop;
            ssy[' '] := othersy;
            ssy[','] := comma;
            ssy['.'] := period;
            ssy[''''] := othersy;
            ssy['['] := lbrack;
            ssy[']'] := rbrack;
            ssy[':'] := colon;
            ssy['^'] := arrow;
            ssy['<'] := relop;
            ssy['>'] := relop;
            ssy[';'] := semicolon;
        end; (*symbols*)

        procedure rators;
            var
                i: integer;
        begin
            for i := 1 to 35 do (*nr of res words*)
                rop[i] := noop;
            rop[5] := inop;
            rop[10] := idiv;
            rop[11] := imod;
            rop[6] := orop;
            rop[13] := andop;
            for i := ordminchar to ordmaxchar do
                sop[chr(i)] := noop;
            sop['+'] := plus;
            sop['-'] := minus;
            sop['*'] := mul;
            sop['/'] := rdiv;
            sop['='] := eqop;
            sop['<'] := ltop;
            sop['>'] := gtop;
        end; (*rators*)

        procedure procmnemonics;
        begin
            sna[1] := ' get';
            sna[2] := ' put';
            sna[3] := ' rdi';
            sna[4] := ' rdr';
            sna[5] := ' rdc';
            sna[6] := ' wri';
            sna[7] := ' wro';
            sna[8] := ' wrr';
            sna[9] := ' wrc';
            sna[10] := ' wrs';
            sna[11] := ' pak';
            sna[12] := ' new';
            sna[13] := ' rst';
            sna[14] := ' eln';
            sna[15] := ' sin';
            sna[16] := ' cos';
            sna[17] := ' exp';
            sna[18] := ' sqt';
            sna[19] := ' log';
            sna[20] := ' atn';
            sna[21] := ' rln';
            sna[22] := ' wln';
            sna[23] := ' sav';
        end; (*procmnemonics*)

        procedure instrmnemonics;
        begin
            mn[0] := ' abi';
            mn[1] := ' abr';
            mn[2] := ' adi';
            mn[3] := ' adr';
            mn[4] := ' and';
            mn[5] := ' dif';
            mn[6] := ' dvi';
            mn[7] := ' dvr';
            mn[8] := ' eof';
            mn[9] := ' flo';
            mn[10] := ' flt';
            mn[11] := ' inn';
            mn[12] := ' int';
            mn[13] := ' ior';
            mn[14] := ' mod';
            mn[15] := ' mpi';
            mn[16] := ' mpr';
            mn[17] := ' ngi';
            mn[18] := ' ngr';
            mn[19] := ' not';
            mn[20] := ' odd';
            mn[21] := ' sbi';
            mn[22] := ' sbr';
            mn[23] := ' sgs';
            mn[24] := ' sqi';
            mn[25] := ' sqr';
            mn[26] := ' sto';
            mn[27] := ' trc';
            mn[28] := ' uni';
            mn[29] := ' stp';
            mn[30] := ' csp';
            mn[31] := ' dec';
            mn[32] := ' ent';
            mn[33] := ' fjp';
            mn[34] := ' inc';
            mn[35] := ' ind';
            mn[36] := ' ixa';
            mn[37] := ' lao';
            mn[38] := ' lca';
            mn[39] := ' ldo';
            mn[40] := ' mov';
            mn[41] := ' mst';
            mn[42] := ' ret';
            mn[43] := ' sro';
            mn[44] := ' xjp';
            mn[45] := ' chk';
            mn[46] := ' cup';
            mn[47] := ' equ';
            mn[48] := ' geq';
            mn[49] := ' grt';
            mn[50] := ' lda';
            mn[51] := ' ldc';
            mn[52] := ' leq';
            mn[53] := ' les';
            mn[54] := ' lod';
            mn[55] := ' neq';
            mn[56] := ' str';
            mn[57] := ' ujp';
            mn[58] := ' ord';
            mn[59] := ' chr';
            mn[60] := ' ujc';
        end; (*instrmnemonics*)

        procedure chartypes;
            var
                i: integer;
        begin
            for i := ordminchar to ordmaxchar do
                chartp[chr(i)] := illegal;
            chartp['a'] := letter;
            chartp['b'] := letter;
            chartp['c'] := letter;
            chartp['d'] := letter;
            chartp['e'] := letter;
            chartp['f'] := letter;
            chartp['g'] := letter;
            chartp['h'] := letter;
            chartp['i'] := letter;
            chartp['j'] := letter;
            chartp['k'] := letter;
            chartp['l'] := letter;
            chartp['m'] := letter;
            chartp['n'] := letter;
            chartp['o'] := letter;
            chartp['p'] := letter;
            chartp['q'] := letter;
            chartp['r'] := letter;
            chartp['s'] := letter;
            chartp['t'] := letter;
            chartp['u'] := letter;
            chartp['v'] := letter;
            chartp['w'] := letter;
            chartp['x'] := letter;
            chartp['y'] := letter;
            chartp['z'] := letter;
            chartp['0'] := number;
            chartp['1'] := number;
            chartp['2'] := number;
            chartp['3'] := number;
            chartp['4'] := number;
            chartp['5'] := number;
            chartp['6'] := number;
            chartp['7'] := number;
            chartp['8'] := number;
            chartp['9'] := number;
            chartp['+'] := special;
            chartp['-'] := special;
            chartp['*'] := special;
            chartp['/'] := special;
            chartp['('] := chlparen;
            chartp[')'] := special;
            chartp['$'] := special;
            chartp['='] := special;
            chartp[' '] := chspace;
            chartp[','] := special;
            chartp['.'] := chperiod;
            chartp[''''] := chstrquo;
            chartp['['] := special;
            chartp[']'] := special;
            chartp[':'] := chcolon;
            chartp['^'] := special;
            chartp[';'] := special;
            chartp['<'] := chlt;
            chartp['>'] := chgt;
            ordint['0'] := 0;
            ordint['1'] := 1;
            ordint['2'] := 2;
            ordint['3'] := 3;
            ordint['4'] := 4;
            ordint['5'] := 5;
            ordint['6'] := 6;
            ordint['7'] := 7;
            ordint['8'] := 8;
            ordint['9'] := 9;
        end;

        procedure initdx;
        begin
            cdx[0] := 0;
            cdx[1] := 0;
            cdx[2] := -1;
            cdx[3] := -1;
            cdx[4] := -1;
            cdx[5] := -1;
            cdx[6] := -1;
            cdx[7] := -1;
            cdx[8] := 0;
            cdx[9] := 0;
            cdx[10] := 0;
            cdx[11] := -1;
            cdx[12] := -1;
            cdx[13] := -1;
            cdx[14] := -1;
            cdx[15] := -1;
            cdx[16] := -1;
            cdx[17] := 0;
            cdx[18] := 0;
            cdx[19] := 0;
            cdx[20] := 0;
            cdx[21] := -1;
            cdx[22] := -1;
            cdx[23] := 0;
            cdx[24] := 0;
            cdx[25] := 0;
            cdx[26] := -2;
            cdx[27] := 0;
            cdx[28] := -1;
            cdx[29] := 0;
            cdx[30] := 0;
            cdx[31] := 0;
            cdx[32] := 0;
            cdx[33] := -1;
            cdx[34] := 0;
            cdx[35] := 0;
            cdx[36] := -1;
            cdx[37] := +1;
            cdx[38] := +1;
            cdx[39] := +1;
            cdx[40] := -2;
            cdx[41] := 0;
            cdx[42] := 0;
            cdx[43] := -1;
            cdx[44] := -1;
            cdx[45] := 0;
            cdx[46] := 0;
            cdx[47] := -1;
            cdx[48] := -1;
            cdx[49] := -1;
            cdx[50] := +1;
            cdx[51] := +1;
            cdx[52] := -1;
            cdx[53] := -1;
            cdx[54] := +1;
            cdx[55] := -1;
            cdx[56] := -1;
            cdx[57] := 0;
            cdx[58] := 0;
            cdx[59] := 0;
            cdx[60] := 0;
            pdx[1] := -1;
            pdx[2] := -1;
            pdx[3] := -2;
            pdx[4] := -2;
            pdx[5] := -2;
            pdx[6] := -3;
            pdx[7] := -3;
            pdx[8] := -3;
            pdx[9] := -3;
            pdx[10] := -4;
            pdx[11] := 0;
            pdx[12] := -2;
            pdx[13] := -1;
            pdx[14] := 0;
            pdx[15] := 0;
            pdx[16] := 0;
            pdx[17] := 0;
            pdx[18] := 0;
            pdx[19] := 0;
            pdx[20] := 0;
            pdx[21] := -1;
            pdx[22] := -1;
            pdx[23] := -1;
        end;

    begin (*inittables*)
        reswords;
        symbols;
        rators;
        instrmnemonics;
        procmnemonics;
        chartypes;
        initdx;
    end; (*inittables*)

(*    function GetInFile: Str255;}
{        var}
{            message, count: Integer;}
{            theAppFile: AppFile;}
{    begin}
{        CountAppFiles(message, count);}
{        if count > 0 then}
{            begin}
{                GetAppFiles(1, theAppFile);}
{                if SetVol(nil, theAppFile.vRefNum) <> noErr then}
{                    ; {We ignore errors for now}
{    GetInFile := theAppFile.fname;}
{end}
{else}
{begin}
{GetInFile := OldFileName('');}
{end;}
{end;}
{*)

{We can't use NewFileName, since we want a default file name.}
{function GetOutFile (prompt, default: Str255): Str255;}
{var}
{reply: SFReply;}
{begin}
{SFPutFile(Point($00800080), prompt, default, nil, reply);}
{if reply.good then}
{begin}
{if SetVol(nil, reply.vRefNum) <> noErr then}
 {We ignore errors for now}
{    GetOutFile := reply.fName;}
{end}
{else}
{GetOutFile := '';}
{end;}

{For Stdfile-dialogs:}
    var
        oldFile, newFile: Str255;
        theTextRect: Rect;
        i: integer;
        compiledBefore: Boolean;

    procedure InitCompiler;
    begin
    end;

    function RunCompiler (fileName: Str255): Str255;
    begin
{theTextRect := screenBits.bounds;}
{theTextRect.top := theTextRect.top + 40; {For menu bar and window top}
{InsetRect(theTextRect, 10, 10);}
{SetTextRect(theTextRect);}
{ShowText;}

{WriteMessageLine('Welcome to the P4Mac p-code compiler!');}
{WriteMessageLine('This program is based on the Public Domain compiler P4.');}
{WriteMessageLine('Quick port for the Mac by Ingemar Ragnemalm - and don''t ask me why.');}

        if not compiledBefore then        {First time, close old "input"}
            close(input);
        compiledBefore := true;
        oldFile := fileName;
        if oldFile = '' then
            oldFile := GetInFile;
        reset(input, oldFile);

        WriteMessageLine('Compiling…');

  (*initialize*)
  (************)
        initscalars;
        initsets;
        inittables;


  (*enter standard names and standard types:*)
  (******************************************)
        level := 0;
        top := 0;
        with display[0] do
            begin
                fname := nil;
                flabel := nil;
                occur := blck
            end;
        enterstdtypes;
        stdnames;
        entstdnames;
        enterundecl;
        top := 1;
        level := 1;
        with display[1] do
            begin
                fname := nil;
                flabel := nil;
                occur := blck
            end;


{default = string between LAST ":" and LAST ".", plus ".pcode"}
        i := length(oldFile) + 1;
        repeat
            i := i - 1;
        until (i < 2) or (oldFile[i] = '.') or (oldFile[i] = ':');
        if i > 1 then
            if oldFile[i] = '.' then
                delete(oldFile, i, length(oldFile) - i + 1);
        repeat
            i := i - 1
        until (i < 2) or (oldFile[i] = ':');
        if i > 1 then
            if oldFile[i] = ':' then
                delete(oldFile, 1, i);

        oldFile := concat(oldFile, '.pcode');
        newFile := GetOutFile('Output file?', oldFile);
        if newFile = '' then
            halt;
(*compile:*)
        rewrite(prr, newFile); (*comment this out when compiling with pcom *)
  (**********)
        insymbol;
        programme(blockbegsys + statbegsys - [casesy]);
        close(prr);
        close(input);
        RunCompiler := newFile;
    end; {RunCompiler}

{procedure test;}
{begin}
{InitCompiler;}
{newFile := RunCompiler('');}
{RunInterpreter(newFile);}
{writeln('Done! Click mouse to exit.');}
{while not Button do}
{end;}

end.